home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / closette / closette.tst < prev    next >
Lisp/Scheme  |  1991-10-22  |  64KB  |  1,949 lines
  1. ;;;-*-Mode:LISP; Package: CLOSETTE; Base:10; Syntax:Common-lisp -*-
  2.  
  3. (in-package 'closette :use '(lisp))
  4.  
  5. ;;; CLOSette tests
  6.  
  7. ;;; From chapter 1
  8.  
  9. (defclass rectangle ()
  10.      ((height :initform 0.0 :initarg :height)
  11.       (width  :initform 0.0 :initarg :width)))
  12.  
  13. (defclass color-mixin ()
  14.      ((cyan    :initform 0 :initarg :cyan)
  15.       (magenta :initform 0 :initarg :magenta)
  16.       (yellow  :initform 0 :initarg :yellow)))
  17.  
  18. (defclass color-rectangle (color-mixin rectangle)
  19.      ((clearp :initform (y-or-n-p "But is it transparent?")
  20.               :initarg :clearp :accessor clearp)))
  21.  
  22. (defgeneric paint (x))
  23.  
  24. (defmethod paint ((x rectangle))                ;Method #1
  25.   (vertical-stroke (slot-value x 'height)
  26.                    (slot-value x 'width)))
  27.  
  28. (defmethod paint :before ((x color-mixin))      ;Method #2
  29.   (set-brush-color (slot-value x 'cyan)
  30.                    (slot-value x 'magenta)
  31.                    (slot-value x 'yellow)))
  32.  
  33. (defmethod paint ((x color-rectangle))          ;Method #3
  34.   (unless (clearp x) (call-next-method)))
  35.  
  36. (setq door
  37.       (make-instance 'color-rectangle
  38.         :width 38 :height 84 :cyan 60 :yellow 55 :clearp nil))
  39.  
  40. (defun vertical-stroke (x y) (declare (ignore x y)) (values))
  41. (defun set-brush-color (x y z) (declare (ignore x y z)) (values))
  42.  
  43. (paint door)
  44.  
  45. ;;; test method combination
  46.  
  47. (defgeneric mctest (x))
  48. (defmethod mctest :around ((x integer))
  49.   (format t "(:around integer)")
  50.   (call-next-method))
  51. (defmethod mctest :around ((x number))
  52.   (format t "(:around number)")
  53.   (call-next-method))
  54. (defmethod mctest :before ((x number))
  55.   (format t "(:before number)"))
  56. (defmethod mctest  ((x number))
  57.   (format t "(primary number)")
  58.   (1+ (call-next-method)))
  59. (defmethod mctest :after ((x number))
  60.   (format t "(:after number)"))
  61. (defmethod mctest :before ((x t))
  62.   (format t "(:before t)"))
  63. (defmethod mctest  ((x t))
  64.   (format t "(primary t)")
  65.   100)
  66. (defmethod mctest :after ((x t))
  67.   (format t "(:after t)"))
  68.  
  69. (mctest 1)
  70. #|(:around integer)(:around number)(:before number)(:before t)
  71.   (primary number)(primary t)(:after t)(:after number)
  72. 101|#
  73.  
  74. ;;; following chapter 1
  75.  
  76. (pprint (macroexpand
  77.  '(defclass color-rectangle (color-mixin rectangle)
  78.      ((clearp :initform (y-or-n-p "But is it transparent?")
  79.               :initarg :clearp :accessor clearp)))))
  80. #|(ensure-class 'color-rectangle
  81.               :direct-superclasses
  82.               (list (find-class 'color-mixin) (find-class 'rectangle))
  83.               :direct-slots
  84.               (list
  85.                (list :name 'clearp :initform
  86.                      '(y-or-n-p "But is it transparent?")
  87.                      :initfunction
  88.                      (function
  89.                       (lambda nil (y-or-n-p "But is it transparent?")))
  90.                      :initargs
  91.                      '(:clearp)
  92.                      :readers
  93.                      '(clearp)
  94.                      :writers
  95.                      '((setf clearp)))))
  96. |#
  97.  
  98.  
  99. ;;; original compute-slots
  100.  
  101. (defun original-compute-slots (class)
  102.   (mapcar #'(lambda (slot)
  103.               (make-effective-slot-definition
  104.                 :name (slot-definition-name slot)
  105.                 :initform (slot-definition-initform slot)
  106.                 :initfunction (slot-definition-initfunction slot)
  107.                 :initargs (slot-definition-initargs slot)))
  108.           (remove-duplicates
  109.             (mapappend #'class-direct-slots
  110.                        (class-precedence-list class))
  111.             :key #'slot-definition-name
  112.             :from-end t)))
  113.  
  114. (equal (original-compute-slots (find-class 'color-rectangle))
  115.        (compute-slots (find-class 'color-rectangle)))
  116. #|T|#
  117.  
  118. (pprint (macroexpand
  119.  '(defgeneric paint (x))))
  120. #|(ensure-generic-function 'paint :lambda-list '(x))|#
  121.  
  122. (pprint (macroexpand
  123.  '(defmethod paint :before ((x color-mixin))    ; Method#2
  124.   (set-brush-color (slot-value x 'cyan)
  125.                    (slot-value x 'magenta)
  126.                    (slot-value x 'yellow)))))
  127. #|(ensure-method (find-generic-function 'paint)
  128.                :lambda-list
  129.                '(x)
  130.                :qualifiers
  131.                '(:before)
  132.                :specializers
  133.                (list (find-class 'color-mixin))
  134.                :body
  135.                '(block paint
  136.                        (set-brush-color (slot-value x 'cyan)
  137.                                         (slot-value x 'magenta)
  138.                                         (slot-value x 'yellow)))
  139.                :environment
  140.                (top-level-environment))
  141. |#
  142.  
  143.  
  144. (find-generic-function 'clearp)
  145. #|#<Closette:Standard-Generic-Function CLOSETTE::CLEARP 16060700>|#
  146.  
  147. (clearp (make-instance 'color-rectangle :clearp t))
  148. #|T|#
  149.  
  150. ;;; change-class
  151.  
  152. (setq o1 (make-instance 'rectangle :height 10 :width 20))
  153. (describe-object o1 *standard-output*)
  154. #| A CLOS object
  155. Printed representation: #<Rectangle 16166710>
  156. Class: #<Standard-Class rectangle 15253764>
  157. Structure 
  158.     height <- 10
  159.     width <- 20
  160. |#
  161.  
  162. (change-class o1 'color-mixin)
  163. (describe-object o1 *standard-output*)
  164. #| A CLOS object
  165. Printed representation: #<Color-Mixin 16166710>
  166. Class: #<Standard-Class color-mixin 15274440>
  167. Structure 
  168.     cyan <- 0
  169.     magenta <- 0
  170.     yellow <- 0
  171. |#
  172. (change-class o1 'standard-object)
  173. (describe-object o1 *standard-output*)
  174. #| A CLOS object
  175. Printed representation: #<Standard-Object 16166710>
  176. Class: #<Standard-Class standard-object 15071700>
  177. Structure
  178. |#
  179.  
  180. (sub-specializer-p (find-class 'color-mixin)
  181.                    (find-class 'rectangle)
  182.                    (find-class 'color-rectangle))
  183. #|T|#
  184. (sub-specializer-p (find-class 'rectangle)
  185.                    (find-class 'rectangle)
  186.                    (find-class 'color-rectangle))
  187. #|NIL|#
  188.  
  189. ;;; exercise
  190.  
  191. (defvar all-tables (make-hash-table :test #'eq))
  192.  
  193. (defun classes-to-applicable-methods-table (gf)
  194.   (let ((table (gethash gf all-tables nil)))
  195.     (unless table
  196.       (setq table (make-hash-table :test #'equal))
  197.       (setf (gethash gf all-tables) table))
  198.     table))
  199.  
  200. (defun better-apply-generic-function (gf args)
  201.   (let* ((required-classes
  202.             (mapcar #'class-of (required-portion gf args)))
  203.          (applicable-methods
  204.             (or (gethash required-classes
  205.                          (classes-to-applicable-methods-table gf)
  206.                          nil)
  207.                 (setf (gethash required-classes
  208.                                (classes-to-applicable-methods-table gf))
  209.                       (compute-applicable-methods-using-classes
  210.                         gf required-classes)))))
  211.     (if (null applicable-methods)
  212.         (error "No matching method for the~@
  213.                 generic function ~S,~@
  214.                 when called with arguments ~:S." gf args)
  215.         (apply-methods gf args applicable-methods))))
  216.  
  217. (better-apply-generic-function 
  218.  (find-generic-function 'make-instance)
  219.  (list 'rectangle))
  220.  
  221. ;;; From chapter 2:
  222.  
  223. (defun subclasses* (class)
  224.   (remove-duplicates
  225.     (cons class 
  226.           (mapappend #'subclasses* 
  227.                      (class-direct-subclasses class)))))
  228.  
  229. (defun subclasses (class) (remove class (subclasses* class)))
  230.  
  231. (subclasses (find-class 'rectangle))
  232. #|(#<Standard-Class COLOR-RECTANGLE>)|#
  233.  
  234. (defvar my-classes 
  235.   (mapcar #'class-name
  236.           (subclasses (find-class 'standard-object))))
  237.  
  238. my-classes
  239. #|(color-mixin rectangle
  240.              color-rectangle
  241.              standard-method
  242.              standard-generic-function
  243.              standard-class)
  244. |#
  245.  
  246.  
  247. (defun display-defclass (class-name)
  248.   (pprint (generate-defclass (find-class class-name)))
  249.   (values))
  250.  
  251. (defun generate-defclass (class)
  252.   `(defclass ,(class-name class)
  253.      ,(mapcar #'class-name (class-direct-superclasses class))
  254.      ,(mapcar #'generate-slot-specification (class-direct-slots class))))
  255.  
  256. (defun generate-slot-specification (slot)
  257.   `(,(slot-definition-name slot)
  258.     ,@(when (slot-definition-initfunction slot)
  259.         `(:initform ,(slot-definition-initform slot)))
  260.     ,@(when (slot-definition-initargs slot)
  261.         (mapappend #'(lambda